home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / Widget / Wpuzzle.stklos < prev    next >
Encoding:
Text File  |  1995-08-23  |  2.2 KB  |  61 lines
  1. ;;;;
  2. ;;;; STk adaptation of the Tk widget demo.
  3. ;;;;
  4. ;;;; This demonstration script creates a toplevel window containing
  5. ;;;; buttons that display bitmaps instead of text.
  6. ;;;;
  7.  
  8. (require "Button")
  9.  
  10. (define (demo-puzzle)
  11.   
  12.   (define (puzzle-switch w num xpos ypos space)
  13.     (let ((x     (vector-ref xpos num)) 
  14.       (y     (vector-ref ypos num))
  15.       (x_spc (vector-ref xpos space)) 
  16.       (y_spc (vector-ref ypos space)))
  17.       (when (or (and (>= y (- y_spc 0.01)) (<= y (+ y_spc 0.01))
  18.              (>= x (- x_spc 0.26)) (<= x (+ x_spc 0.26)))
  19.         (and (>= x (- x_spc 0.01)) (<= x (+ x_spc 0.01))
  20.              (>= y (- y_spc 0.26)) (<= y (+ y_spc 0.26))))
  21.         (vector-set! xpos space x)
  22.         (vector-set! xpos num x_spc)
  23.         (vector-set! ypos space y)
  24.         (vector-set! ypos num y_spc)
  25.         (place w :relx x_spc :rely y_spc))))
  26.  
  27.  
  28.   (let* ((w     (make-demo-toplevel "puzzle"
  29.                     "15-Puzzle Demonstration"
  30.                     "This window shows three ways of using bitmaps or images in radiobuttons and checkbuttons.  On the left are two radiobuttons, each of which displays a bitmap and an indicator.  In the middle is a checkbutton that displays a different image depending on whether it is selected or not.  On the right is a checkbutton that displays a single bitmap but changes its background color to indicate whether or not it is selected."))
  31.      (frame    (make <Frame> :parent w :width 120 :height 120 :border-width 2
  32.                         :relief "sunken")))
  33.  
  34.     (pack frame :side "top" :pady 20 :padx 20)
  35.  
  36.     (let ((order '#(3 1 6 2 5 7 15 13 4 11 8 9 14 10 12))
  37.       (xpos  (make-vector 16))
  38.       (ypos  (make-vector 16))
  39.       (space 0))
  40.       
  41.       (do ((i   0 (+ i 1)))
  42.       ((= i 15))
  43.       (let* ((num (vector-ref order i))
  44.          (b   (make <Button> :parent frame :text num
  45.                 :highlight-thickness 0)))
  46.         ;; Set the command of the button (and grab current environment)
  47.         (set! (command b)  (lambda ()
  48.                  (puzzle-switch b num xpos ypos space)))
  49.          
  50.         (vector-set! xpos num (* (modulo i 4) 0.25))
  51.         (vector-set! ypos num (* (floor (/ i 4)) 0.25))
  52.         
  53.         (place b :relx (vector-ref xpos num)
  54.              :rely (vector-ref ypos num)
  55.              :relwidth 0.25
  56.              :relheight 0.25)))
  57.       (vector-set! xpos space 0.75)
  58.       (vector-set! ypos space 0.75))))
  59.  
  60.  
  61.